;;;;
;;;; MACROS FOR IMPORTING THINGS FROM THE UNDERLYING .NET ENVIRONMENT
;;;;

(define (%import varname value t . maybe-native-name)
  (define v (lookup global-environment varname))

  (unless (null? maybe-native-name)
    (set (native-name v)
	 (car maybe-native-name)))
  (set (current-value v) value)
  (set (type v) t))

(define-syntax import
  (syntax-rules ()
    ((import (?name ?cs-name ?type) ...)
     (begin (%import '?name
		     (new native-procedure '?name #f #f '?cs-name)
		     ?type)
	    ...))))

(define-syntax import-types
  (syntax-rules ()
    ((import-types (?name ?scheme-name) ...)
     (begin (%import '?name ?scheme-name type-type) ...))))

(define-syntax import-operators
  (syntax-rules ()
    ((import-operators (?name ?cs-name ?prec ?type) ...)
     (begin (let ((t ?type))
	      (%import '?name
		       (new native-operator '?name #f ?name ?cs-name ?prec t)
		       t))
	    ...))))

(define-syntax import-enumeration
  (syntax-rules ()
    ((import-enumeration enumeration-name (name native) ...)
     (begin (define-imported-object name
	      (string-append enumeration-name
			     "."
			     native)
	      integer-type)
	    ...))))

; (or " || " 0)
; (and " && " 0))

;;;;
;;;; FIELDS AND METHODS 
;;;;

(define-syntax import-methods
  (syntax-rules ()
    ((import-methods (name native-name type) ...)
     (begin (%import 'name
		     (new method native-name '() type)
		     type)
	    ...))))

(define-syntax import-fields
  (syntax-rules ()
    ((import-fields (name native-name type) ...)
     (begin (%import 'name
		     (new field native-name type)
		     type)
	    ...))))

;;;;
;;;; CLASS DEFINITIONS
;;;;

(define-syntax define-imported-class
  (syntax-rules (define)
    ((define-imported-class (?classname (?type ?constructor-arg) ...) ?parent
       ?member-defs ...)
     (really-define-imported-class ?classname (native-type-name '?classname)
				   (type-expression-value '?parent)
				   (list (type-expression-value '?type) ...)
				   ?member-defs ...))
    ((define-imported-class (?classname ?native-name
					(?type ?constructor-arg) ...)
       ?parent
       ?member-defs ...)
     (really-define-imported-class ?classname ?native-name
				   (type-expression-value '?parent)
				   (list (type-expression-value '?type) ...)
				   ?member-defs ...))
    ((define-imported-class ?classname ?parent
       ?member-defs ...)
     (really-define-imported-class ?classname (native-type-name '?classname)
				   (type-expression-value '?parent)
				   '()
				   ?member-defs ...))))

(define-syntax really-define-imported-class
  (syntax-rules ()
    ((really-define-imported-class ?classname ?native-name
				   ?parent
				   ?constructor-args
				   ?member-defs ...)
     (begin
       (let ((class (make-user-type '?classname ?native-name ?parent
				    ?constructor-args)))
	 (%import '?classname class type-type ?native-name)
	 (define-imported-member class ?member-defs) ...)))))
	 
(define-syntax define-imported-member
  (syntax-rules (define)
    ((define-imported-member ?class
       (define (?method (?atype ?arg) ...)
	 (?keys ...)
	 ?type))
     (let ((return-type (type-expression-value '?type)))
       (%import '?method
		(new method
		     (native-method-name '?method)
		     '(?keys ...)
		     return-type)
		(proc (?class (type-expression-value '?atype) ...)
		      return-type))))
    ((define-imported-member ?class
       (define (?method ?native-name (?atype ?arg) ...)
	 (?keys ...)
	 ?type))
     (let ((return-type (type-expression-value '?type)))
       (%import '?method
		(new method
		     ?native-name
		     '(?keys ...)
		     return-type)
		(proc (?class (type-expression-value '?atype) ...)
		      return-type))
       (set (native-name (parse '?method)) ?native-name)))
    ((define-imported-member ?class
       (define ?field
	 (?keys ...)
	 ?type))
     (let ((t (type-expression-value '?type)))
       (%import '?field
		(new field
		     (native-field-name '?field)
		     t)
		(proc (?class) t))))
    ((define-imported-member ?class
       (define ?field ?native-name
	 (?keys ...)
	 ?type))
     (let ((t (type-expression-value '?type)))
       (%import '?field
		(new field
		     ?native-name
		     t)
		(proc (?class) t))))))

(define-syntax define-imported-object
  (syntax-rules ()
    ((define-imported-object ?name ?native-name ?type)
     (%import-object '?name ?native-name '?type))))

(define (%import-object name native typeexp)
  (define var (parse name))
  (set (native-name var) native)
  (set (type var) typeexp)
  (set (type-wired? var) #t))

(define (%import-static name native-name type)
  (%import name
	   (new native-procedure name '() #f native-name)
	   type))

(define-syntax import-static
  (syntax-rules ()
    ((import-static (name native type) ...)
     (begin (%import-static 'name native type) ...))))